home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Pascal Super Library
/
Pascal Super Library (CW International)(1997).bin
/
LIBRARY
/
TIPS
/
STATUS.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1991-10-09
|
4KB
|
150 lines
{************************************************}
{ }
{ Turbo Pascal for Windows }
{ Tips & Techniques Demo Program }
{ Copyright (c) 1991 by Borland International }
{ }
{************************************************}
program MDIStatusLine;
{$R MDIAPP.RES}
uses WObjects, WinTypes, WinProcs, Strings, WinDos;
const
StatusLineHeight = 20;
type
PStatusLine = ^TStatusLine;
TStatusLine = object(TWindow)
constructor Init(AParent: PWindowsObject);
function GetClassName: PChar; virtual;
procedure GetWindowClass(var AWndClass : TWndClass); virtual;
procedure WriteTime;
end;
PMyMDIWindow = ^TMyMDIWindow;
TMyMDIWindow = object(TMDIWindow)
StatusLine : PStatusLine;
constructor Init(ATitle: PChar; AMenu: HMenu);
destructor Done; virtual;
procedure SetUpWindow; virtual;
procedure WMSize(var Message: TMessage);
virtual wm_Size;
procedure WMTimer(var Message: TMessage);
virtual wm_Timer;
end;
TMDIApp = object(TApplication)
procedure InitMainWindow; virtual;
end;
constructor TStatusLine.Init(AParent: PWindowsObject);
begin
TWindow.Init(AParent, ''); { create the window normally }
SetFlags(wb_MDIChild, False); {turn off the MDI flag that TWindow set }
Attr.Style := ws_Border or ws_Child or ws_Visible;
end;
function TStatusLine.GetClassName: PChar;
begin
GetClassName := 'TurboStatusLine';
end;
procedure TStatusLine.GetWindowClass(var AWndClass : TWndClass);
begin
TWindow.GetWindowClass(AWndClass);
AWndClass.hbrBackGround := GetStockObject(White_Brush);
end;
procedure TStatusLine.WriteTime;
var
DC: HDC;
S, Temp: array[0..100] of Char;
Hour, Minute, Second, hs: Word;
Width: Integer;
begin
DC := GetDC(HWindow);
GetTime(Hour, Minute, Second, hs);
Str(Hour: 2, S);
StrCat(S, ':');
Str(Minute:2, Temp);
if Temp[0] = ' ' then Temp[0] := '0';
StrCat(S, Temp);
StrCat(S, ':');
Str(Second:2, Temp);
if Temp[0] = ' ' then Temp[0] := '0';
StrCat(S, Temp);
TextOut(DC, 5, 2, S, StrLen(S));
Width := LoWord(GetTextExtent(DC, S, StrLen(S)));
MoveTo(DC, Width + 10, 0);
LineTo(DC, Width + 10, StatusLineHeight);
ReleaseDC(HWindow, DC);
end;
constructor TMyMDIWindow.Init(ATitle: PChar; AMenu: HMenu);
begin
TMDIWindow.Init(ATitle, AMenu);
StatusLine := New(PStatusLine, Init(@Self));
end;
destructor TMyMDIWindow.Done;
begin
KillTimer(HWindow, 1);
TWindow.Done;
end;
procedure TMyMDIWindow.SetUpWindow;
begin
TMDIWindow.SetUpWindow;
SetTimer(HWindow, 1, 1000, Nil);
end;
procedure TMyMDIWindow. WMSize(var Message: TMessage);
begin
TMDIWindow.WMSize(Message);
{ Always check for nil window pointers and invalid HWindow handles.
Windows can send your main window WMSize messages while the child
windows are being destroyed, which can produce some hard to track
down UAEs. }
if (ClientWnd <> nil) and (ClientWnd^.HWindow <> 0) then
if Message.LParamHi > 20 then
MoveWindow(ClientWnd^.HWindow, 0, 0, Message.LParamLo, Message.LParamHi -
StatusLineHeight, True);
if (StatusLine <> nil) and (StatusLine^.HWindow <> 0) then
if Message.LParamHi > 20 then
MoveWindow(StatusLine^.HWindow, - 1, Message.LParamHi - StatusLineHeight,
Message.LParamLo + 2, Message.LParamHi, True);
{ The -1 and +2 are to hide the left and right borders of this
Status window. It looks funny with no border at all, but it looks funny
with extra thick borders on the left and right. This sets a happy medium. }
end;
procedure TMyMDIWindow.WMTimer(var Message: TMessage);
begin
StatusLine^.WriteTime;
end;
{ Construct the THelloApp's MainWindow object, loading its menu }
procedure TMDIApp.InitMainWindow;
begin
MainWindow := New(PMyMDIWindow, Init('MDI StatusLine',
LoadMenu(HInstance, 'MDIMenu')));
end;
{ Declare a variable of type TMDIApp}
var
MDIApp: TMDIApp;
{ Run the MDIApp }
begin
MDIApp.Init('MDIApp');
MDIApp.Run;
MDIApp.Done;
end.